home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / sys / spkernel.t < prev    next >
Text File  |  1989-06-30  |  22KB  |  684 lines
  1. (herald spkernel (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. (define (risc-big-bang)
  27.   (lap (big_bang handle-stack-base
  28.          icall-bad-proc icall-wrong-nargs
  29.          handle-undefined-effect
  30.         really-gc
  31.         heap-overflow-error interrupt-handler cont-wrong-nargs)
  32.  
  33.     (move link-reg %g6)
  34.     (store l nil-reg (d@nil %%cdr))            ; (cdr '()) = '()
  35.     (store l nil-reg (d@nil %%car))             ; (car '()) = '()
  36.     (store l P (d@nil slink/kernel))        ; save kernel pointer
  37.  
  38.     (movea %extra-args extra)
  39.     (store l extra (d@nil slink/make-extra-args))
  40.     (movea %nary-setup extra)
  41.     (store l extra (d@nil slink/nary-setup))
  42.     (movea %undefined-effect extra)
  43.     (store l extra (d@nil slink/undefined-effect))
  44.     (movea %make-pair extra)
  45.     (store l extra (d@nil slink/make-pair))
  46.     (movea %make-extend extra)
  47.     (store l extra (d@nil slink/make-extend))
  48.     (movea %heap-overflow extra)
  49.     (store l extra (d@nil slink/heap-overflow))
  50.     (movea %set extra)
  51.     (store l extra (d@nil slink/set))
  52.     (movea %icall extra)
  53.     (store l extra (d@nil slink/icall))
  54.     (movea %cont-wrong-nargs extra)
  55.     (store l extra (d@nil slink/cont-wrong-nargs))
  56.     (movea %kernel-begin extra)
  57.     (store l extra (d@nil slink/kernel-begin))
  58.     (movea %kernel-end extra)
  59.     (store l extra (d@nil slink/kernel-end))
  60.  
  61.     ;; initialize root process, stored in outer space?  
  62.  
  63. ;    (sub ($ 4) sp)
  64. ;    (movec #xBADBAD extra)                       ; distinguished value
  65. ;    (store l extra (d@r sp 0))
  66. ;    (movea stack-base-template extra)
  67. ;    (sub ($ 2) extra link-reg)        ;this will become the stack base
  68. ;    (sub ($ 4) sp  extra)
  69. ;    (store l extra (d@nil slink/stack))    ;point to future stack base
  70.     (store l nil-reg (d@nil slink/dynamic-state))
  71.  
  72.     (store l nil-reg (d@nil slink/doing-gc?))
  73.     (store l nil-reg (d@nil slink/k-list))
  74.     (store l nil-reg (d@nil slink/gc-weak-set-list))
  75.     (store l nil-reg (d@nil slink/gc-weak-alist-list))
  76.     (store l nil-reg (d@nil slink/gc-weak-table-list))
  77.     (store l nil-reg (d@nil slink/snapper-freelist))
  78.     (store l nil-reg (d@nil slink/pair-freelist))
  79.     (load l (d@r P (static big_bang)) P)
  80.     (load l (d@r p 2) p)
  81.     (jr (d@r %g6 0))
  82.     (noop)
  83.  
  84. %extra-args                ;bytes in scratch
  85.     (load l (d@nil slink/area-frontier) extra)
  86.     (add extra scratch)
  87.     (load l (d@nil slink/area-limit) vector)
  88.     (j> scratch vector %extra-args-heap-overflow)
  89.     (store l scratch (d@nil slink/area-frontier))
  90.     (add ($ 8) scratch vector)
  91.     (add ($ 3) extra extra-args)
  92.     (add ($ 11) extra)
  93. extra-args-test
  94.     (j> extra vector extra-args-done)
  95.     (store l extra (d@r extra -11))
  96.     (add ($ 8) extra)
  97.     (jbr extra-args-test)
  98. extra-args-done
  99.     (store l nil-reg (d@r extra -19))
  100.     (jr (d@r link-reg 0))
  101.     (noop)
  102. %extra-args-heap-overflow
  103.     (store l zero (d@nil slink/doing-gc?))
  104.     (sub extra scratch)
  105.     (move link-reg extra)            ;heap overflow moves it back
  106.     (load l (d@nil slink/heap-overflow) link-reg)
  107.     (jalr (d@r link-reg 0))
  108.     (noop)
  109.     (store l nil-reg (d@nil slink/doing-gc?))
  110.     (jbr %extra-args)
  111.   
  112. ;; in nary-setup NARGS is referred to as %i4 because the value in nargs from
  113. ;; the caller has passed through a save by the jumper to nary-setup!!
  114.  
  115. %nary-setup                                 ; required args in vector
  116.   (sub ($ 1) %I4)
  117.   (sub vector %i4 parassign-extra)
  118.   (j= parassign-extra zero no-rest-args)
  119.   (sll ($ 3) parassign-extra)            ;bytes to cons
  120. %nary-setup-continue                        ; lose, lose
  121.   (load l (d@nil slink/area-frontier) AN)
  122.   (add an parassign-extra)
  123.   (load l (d@nil slink/area-limit) extra)
  124.   (j> parassign-extra extra %nary-make-pair-heap-overflow)
  125.   (store l parassign-extra (d@nil slink/area-frontier))
  126.   (add ($ 3) an)
  127.   (add ($ 8) an extra)
  128.   (j= vector zero move-a1)
  129.   (j= vector ($ 1) move-a2)
  130.   (j= vector ($ 2) move-a3)
  131.   (j= vector ($ 3) move-a4)
  132.   (j= vector ($ 4) move-a5)
  133. many-loop
  134.   (load l (d@r extra-args %%car) vector)
  135.   (load l (d@r extra-args %%cdr) extra-args)
  136.   (store l vector (d@r extra -7))
  137.   (store l extra (d@r extra -11))
  138.   (add ($ 8) extra)
  139.   (add ($ 1) vector)
  140.   (j< vector %i4 many-loop)
  141.   (jr (d@r link-reg 0))
  142.   (store l extra-args (d@r extra -19))
  143. move-a1
  144.   (store l a1 (d@r extra -7))
  145.   (store l extra (d@r extra -11))
  146.   (add ($ 8) extra)
  147.   (add ($ 1) vector)
  148.   (j>= vector %i4 registers-moved)
  149. move-a2
  150.   (store l a2 (d@r extra -7))
  151.   (store l extra (d@r extra -11))
  152.   (add ($ 8) extra)
  153.   (add ($ 1) vector)
  154.   (j>= vector %i4 registers-moved)
  155. move-a3
  156.   (store l a3 (d@r extra -7))
  157.   (store l extra (d@r extra -11))
  158.   (add ($ 8) extra)
  159.   (add ($ 1) vector)
  160.   (j>= vector %i4 registers-moved)
  161. move-a4
  162.   (store l a4 (d@r extra -7))
  163.   (store l extra (d@r extra -11))
  164.   (add ($ 8) extra)
  165.   (add ($ 1) vector)
  166.   (j>= vector %i4 registers-moved)
  167. move-a5
  168.   (store l a5 (d@r extra -7))
  169.   (store l extra (d@r extra -11))
  170.   (add ($ 8) extra)
  171.   (add ($ 1) vector)
  172.   (j>= vector %i4 registers-moved)
  173.   (jr (d@r link-reg 0))
  174.   (store l extra-args (d@r extra -19))
  175. registers-moved
  176.   (jr (d@r link-reg 0))
  177.   (store l nil-reg (d@r extra -19))
  178. no-rest-args
  179.   (jr (d@r link-reg 0))
  180.   (move nil-reg an)
  181. %nary-make-pair-heap-overflow
  182.     (store l zero (d@nil slink/doing-gc?))
  183.     (sub an parassign-extra)
  184.     (move link-reg extra)            ;heap overflow moves it back
  185.     (load l (d@nil slink/heap-overflow) link-reg)
  186.     (jalr (d@r link-reg 0))
  187.     (noop)
  188.     (store l nil-reg (d@nil slink/doing-gc?))
  189.     (jbr %nary-setup-continue)
  190.  
  191. %make-pair
  192.     ;; return pair in AN
  193.     (load l (d@nil slink/area-frontier) AN)
  194.     (add ($ 8) AN)
  195.     (load l (d@nil slink/area-limit) extra)
  196.     (j> AN extra %make-pair-heap-overflow)
  197. %make-pair-continue
  198.     (store l AN (d@nil slink/area-frontier))
  199.     (sub ($ 5) AN)
  200.     (clear l (d@r AN %%car))
  201.     (clear l (d@r AN %%cdr))
  202.     (jr (d@r link-reg 0))
  203.     (noop)
  204.  
  205. %make-pair-heap-overflow
  206.     (store l zero (d@nil slink/doing-gc?))
  207.     (move link-reg extra)            ;heap overflow moves it back
  208.     (jl %heap-overflow) 
  209.     (noop)
  210.     (load l (d@nil slink/area-frontier) AN)
  211.     (add ($ 8) AN)
  212.     (load l (d@nil slink/area-limit) scratch)
  213.     (j> AN scratch %horrible-heap-overflow)
  214.     (store l nil-reg (d@nil slink/doing-gc?))
  215.     (jbr %make-pair-continue)
  216.     
  217.  
  218. %make-extend
  219.     ;; receive descriptor in An, size in bytes in scratch,
  220.     ;; return extend in AN.
  221.     (load l (d@nil slink/area-frontier) extra)
  222.     (add ($ 4) scratch)                           
  223.     (add extra scratch)
  224.     (load l (d@nil slink/area-limit) parassign-extra)
  225.     (j> scratch parassign-extra %make-extend-heap-overflow)
  226. %make-extend-continue  
  227.     (store l scratch (d@nil slink/area-frontier))
  228.     (store l AN (d@r extra 0))
  229.     (add ($ 2) extra AN)
  230.     (add ($ 4) extra)
  231.     (jbr extend-test)
  232. extend-loop
  233.     (clear l (d@r extra 0))
  234.     (add ($ 4) extra)
  235. extend-test
  236.     (j> scratch extra extend-loop)
  237. copy-done
  238.     (jr (d@r link-reg 0))
  239.     (noop)
  240.    
  241. %make-extend-heap-overflow
  242.     (store l zero (d@nil slink/doing-gc?))
  243.     (sub extra scratch)
  244.     (move link-reg extra)            ;heap overflow moves it back
  245.     (jl %heap-overflow) 
  246.     (noop)
  247.     (load l (d@nil slink/area-frontier) extra) ; get area-frontier
  248.     (add extra scratch) 
  249.     (load l (d@nil slink/area-limit) parassign-extra) ; get area-frontier
  250.     (j> scratch parassign-extra %horrible-heap-overflow)
  251.     (store l nil-reg (d@nil slink/doing-gc?))
  252.     (jbr %make-extend-continue)
  253.  
  254. %heap-overflow                ;extra and link-reg have been swapped
  255.    (noop)
  256. #|    (sub ($ (* (+ *argument-registers* 9) 4)) sp) ;scratch,vector,extra::
  257.                       ;an+1,link,p,an,eargs,parassign-extra
  258.     (store l link-reg (d@r sp 0))        ;internal return address
  259.     (store l extra-args (d@r sp 4))
  260.     (store l parassign-extra (d@r sp 8))
  261.     (store l an+1 (d@r sp 12))
  262.     (store l an (d@r sp 16))
  263.     (store l a11 (d@r sp 20))
  264.     (store l a10 (d@r sp 24))
  265.     (store l a9 (d@r sp 28))
  266.     (store l a8 (d@r sp 32))
  267.     (store l a7 (d@r sp 36))
  268.     (store l a6 (d@r sp 40))
  269.     (store l a5 (d@r sp 44))
  270.     (store l a4 (d@r sp 48))
  271.     (store l a3 (d@r sp 52))
  272.     (store l a2 (d@r sp 56))
  273.     (store l a1 (d@r sp 60))
  274.     (store l p (d@r sp 64))
  275.     (store l scratch (d@r sp 68))
  276.     (store l vector (d@r sp 72))
  277.     (store l extra (d@r sp 76))        ;real return address
  278.     (add ($ (+ (* (+ *argument-registers* 8) 4) 2)) sp a1) ;stack to gc
  279.     (add ($ 2) sp a2)            ;gc-frame to gc
  280.     (load l (d@nil slink/kernel) P)
  281.     (load l (d@r P (static really-gc)) P)
  282.     (load l (d@r p 2) p)
  283.     (load l (d@r P -2) extra)
  284.     (jalr (d@r extra 2))
  285.     (noop)
  286.     (sub ($ 4) sp a2)
  287.     (mask ($ 31) a2 a3)            ;check for multiple of 8 longwords
  288.     (j= a3 zero gc-zero)
  289.     (store l zero (d@r a2 0))
  290.     (sub ($ 4) a2)
  291.     (mask ($ 31) a2 a3)            ;check for multiple of 8 longwords
  292.     (j= a3 zero gc-zero)
  293.     (store l zero (d@r a2 0))
  294.     (sub ($ 4) a2)
  295.     (mask ($ 31) a2 a3)            ;check for multiple of 8 longwords
  296.     (j= a3 zero gc-zero)
  297.     (store l zero (d@r a2 0))
  298.     (sub ($ 4) a2)
  299.     (mask ($ 31) a2 a3)            ;check for multiple of 8 longwords
  300.     (j= a3 zero gc-zero)
  301.     (store l zero (d@r a2 0))
  302.     (sub ($ 4) a2)
  303.     (mask ($ 31) a2 a3)            ;check for multiple of 8 longwords
  304.     (j= a3 zero gc-zero)
  305.     (store l zero (d@r a2 0))
  306.     (sub ($ 4) a2)
  307.     (mask ($ 31) a2 a3)            ;check for multiple of 8 longwords
  308.     (j= a3 zero gc-zero)
  309.     (store l zero (d@r a2 0))
  310.     (sub ($ 4) a2)
  311.     (mask ($ 31) a2 a3)            ;check for multiple of 8 longwords
  312.     (j= a3 zero gc-zero)
  313.     (store l zero (d@r a2 0))
  314.     (sub ($ 4) a2)
  315. gc-zero
  316.     (movec #x80000 a3)            ;(* 512 1024)
  317.     (sub ($ 3) nil-reg a1)        ;bottom of stack
  318.     (sub a3 a1)            ;lowest possible stack location
  319.     (add ($ 31) a1)
  320.     (movec #xffffffe0 scratch)
  321.     (and scratch a1)            ;make multiple of 8 longwords
  322.     (j= a1 a2 gc-zero-done)
  323. gc-zero-loop
  324.     (store l zero (d@r a1 0))
  325.     (store l zero (d@r a1 4))
  326.     (store l zero (d@r a1 8))
  327.     (store l zero (d@r a1 12))
  328.     (store l zero (d@r a1 16))
  329.     (store l zero (d@r a1 20))
  330.     (store l zero (d@r a1 24))
  331.     (store l zero (d@r a1 28))
  332.     (add ($ 32) a1)
  333.     (jn= a1 a2 gc-zero-loop)
  334. gc-zero-done
  335.     (store l zero (d@r a1 0))        ;last one
  336.     (load l (d@r sp 0) extra)
  337.     (load l (d@r sp 4) extra-args)
  338.     (load l (d@r sp 8) parassign-extra)
  339.     (load l (d@r sp 12) an+1)
  340.     (load l (d@r sp 16) an)
  341.     (load l (d@r sp 20) a11)
  342.     (load l (d@r sp 24) a10)
  343.     (load l (d@r sp 28) a9)
  344.     (load l (d@r sp 32) a8)
  345.     (load l (d@r sp 36) a7)
  346.     (load l (d@r sp 40) a6)
  347.     (load l (d@r sp 44) a5)
  348.     (load l (d@r sp 48) a4)
  349.     (load l (d@r sp 52) a3)
  350.     (load l (d@r sp 56) a2)
  351.     (load l (d@r sp 60) a1)
  352.     (load l (d@r sp 64) p)
  353.     (load l (d@r sp 68) scratch)
  354.     (load l (d@r sp 72) vector)
  355.     (load l (d@r sp 76) link-reg)
  356.     (store l zero (d@r sp 68))        ;clear slot for scratch
  357.     (store l zero (d@r sp 72))        ;clear slot for vector
  358.     (jr extra)
  359.     (add ($ (* (+ *argument-registers* 9) 4)) sp) ;scratch,vector,extra::
  360.                       ;link,p,an,extra-args,parassign-extra
  361. |#           
  362. ;;; the template header byte has high bit set if nary
  363.  
  364. %icall                     
  365.   (mask ($ 3) P vector)
  366.   (jn= vector ($ tag/extend) %icall-bad-proc)
  367.   (load l (d@r P -2) extra)                         ; fetch header
  368.   (mask ($ 3) extra vector)                 ; check header is extend
  369.   (jn= vector ($ tag/extend) %icall-bad-proc)
  370.   (load ub (d@r extra template/header) vector)
  371.   (jn= vector ($ header/template) %icall-check-nary)
  372.   (load sb (d@r extra template/nargs) parassign-extra)         ; check number of args
  373.   (j= parassign-extra nargs %icall-ok)
  374.   (jbr %icall-wrong-nargs)
  375. %icall-check-nary
  376.   (jn= vector ($ (fx+ header/template 128)) %icall-bad-proc)
  377.   (load sb (d@r extra template/nargs) parassign-extra)         ; check number of args
  378.   (j> parassign-extra NARGS %icall-wrong-nargs)
  379. %icall-ok
  380.   (jr (d@r extra 2))
  381.   (noop)
  382.  
  383. %icall-bad-proc
  384.   (store l p (d@nil slink/P))
  385.   (load l (d@nil slink/kernel) P)
  386.   (load l (d@r P (static icall-bad-proc)) P)
  387.   (load l (d@r p 2) p)
  388.   (load l (d@r P -2) extra)
  389.   (jr (d@r extra 2))
  390.   (noop)
  391.  
  392. %icall-wrong-nargs
  393.   (store l p (d@nil slink/P))
  394.   (load l (d@nil slink/kernel) P)
  395.   (load l (d@r P (static icall-wrong-nargs)) P)
  396.   (load l (d@r p 2) p)
  397.   (load l (d@r P -2) extra)
  398.   (jr (d@r extra 2))
  399.   (noop)
  400.  
  401.  
  402. %deferred-interrupts
  403. #|    (sub ($ (* (+ *argument-registers* 7) 4)) sp) 
  404.                       ;an+1,link,p,an,eargs,parassign-extra,
  405.     (store l extra (d@r sp 0))        ;extra
  406.     (store l extra-args (d@r sp 4))
  407.     (store l parassign-extra (d@r sp 8))
  408.     (store l an+1 (d@r sp 12))
  409.     (store l an (d@r sp 16))
  410.     (store l a11 (d@r sp 20))
  411.     (store l a10 (d@r sp 24))
  412.     (store l a9 (d@r sp 28))
  413.     (store l a8 (d@r sp 32))
  414.     (store l a7 (d@r sp 36))
  415.     (store l a6 (d@r sp 40))
  416.     (store l a5 (d@r sp 44))
  417.     (store l a4 (d@r sp 48))
  418.     (store l a3 (d@r sp 52))
  419.     (store l a2 (d@r sp 56))
  420.     (store l a1 (d@r sp 60))
  421.     (store l p (d@r sp 64))
  422.     (store l link-reg (d@r sp 68))
  423.     (load l (d@nil slink/kernel) P)
  424.     (load l (d@r P (static interrupt-handler)) P)
  425.     (load l (d@r p 2) p)
  426.     (load l (d@r P -2) extra)
  427.     (jalr (d@r extra 2))
  428.     (add ($ 12) link-reg)
  429.     (template 17 -1 t)
  430.     (load l (d@r sp 0) extra)
  431.     (load l (d@r sp 4) extra-args)
  432.     (load l (d@r sp 8) parassign-extra)
  433.     (load l (d@r sp 12) an+1)
  434.     (load l (d@r sp 16) an)
  435.     (load l (d@r sp 20) a11)
  436.     (load l (d@r sp 24) a10)
  437.     (load l (d@r sp 28) a9)
  438.     (load l (d@r sp 32) a8)
  439.     (load l (d@r sp 36) a7)
  440.     (load l (d@r sp 40) a6)
  441.     (load l (d@r sp 44) a5)
  442.     (load l (d@r sp 48) a4)
  443.     (load l (d@r sp 52) a3)
  444.     (load l (d@r sp 56) a2)
  445.     (load l (d@r sp 60) a1)
  446.     (load l (d@r sp 64) p)
  447.     (load l (d@r sp 68) link-reg)
  448.     (jr link-reg)
  449.     (sub ($ (* (+ *argument-registers* 7) 4)) sp) ;extra.
  450.                       ;link,p,an,extra-args,parassign-extra
  451. |#
  452. %kernel-begin
  453.   (noop)
  454. %cont-wrong-nargs
  455.   (sub ($ 2) link-reg extra)
  456.   (store l extra (d@nil slink/P))
  457.   (load l (d@nil slink/kernel) P)
  458.   (load l (d@r P (static cont-wrong-nargs)) P)
  459.   (load l (d@r p 2) p)
  460.   (load l (d@r P -2) extra)
  461.   (jr (d@r extra 2))
  462.   (sub nargs zero nargs)
  463.                 
  464.  
  465. %set                                        ; a location is (unit  . index)
  466. ;;  vcell in parassign-extra 
  467. ;; regs pextra=value,scratch=len counter,extra-args=snapper,an-1=vector
  468.    (load l (d@r parassign-extra 6) an-1)                  ; get locations
  469.    (load l (d@r parassign-extra 2) parassign-extra) ;get value
  470.    (load l (d@r an-1 2) an-1)                  ; get the vector from weak-alist
  471.    (load l (d@r an-1 -2) scratch)
  472.    (sra ($ 8) scratch)
  473.    (sll ($ 2) scratch)
  474.    (sub ($ 4) scratch)            ;so offset is less than 4 (88000)
  475.    (jbr %set-test)
  476. %set-loop
  477.    (load l (d@nil slink/snapper-freelist) an)
  478.    (j= an nil-reg cons-snapper)
  479.    (load l (d@r an %%car) extra-args)
  480.    (load l (d@r an %%cdr) vector)
  481.    (store l vector (d@nil slink/snapper-freelist))
  482.    (load l (d@nil slink/pair-freelist) vector)
  483.    (store l vector (d@r an %%cdr))
  484.    (store l an (d@nil slink/pair-freelist))
  485. %real-top
  486.    (store l parassign-extra (d@r extra-args 2)) ;snapper-value
  487.    (add an-1 scratch vector)
  488.    (load l (d@r vector -2) an)        ;unit
  489.    (store l an (d@r extra-args 6))        ;snapper-unit
  490.    (load l (d@r vector 2) vector)    ;index
  491.    (store l vector (d@r extra-args 10))    ;snapper-index
  492.    (add an vector vector)
  493.    (store l extra-args (d@r vector 2))    ;store away snapper
  494.    (sub ($ 8) scratch)
  495. %set-test
  496.    (j> scratch zero %set-loop)
  497.    (jr (d@r link-reg 0))
  498.    (noop)
  499. cons-snapper
  500.    (load l (d@nil slink/area-frontier) AN)
  501.    (add ($ 16) AN)
  502.    (load l (d@nil slink/area-limit) vector)
  503.    (j> AN vector %set-heap-overflow)
  504. %set-continue                        ; lose, lose
  505.    (store l AN (d@nil slink/area-frontier))
  506.    (add ($ -14) an extra-args)
  507.    (load l (d@nil slink/kernel) an)
  508.    (load l (d@r an (static *link-snapper-template*)) an)
  509.    (load l (d@r an 2) an)
  510.    (store l an (d@r extra-args -2))
  511.    (jbr %real-top)
  512. %set-heap-overflow
  513.     (store l zero (d@nil slink/doing-gc?))
  514.     (move link-reg extra)            ;heap overflow moves it back
  515.     (jl %heap-overflow) 
  516.     (noop)
  517.     (load l (d@nil slink/area-frontier) AN)
  518.     (add ($ 16) AN)
  519.     (load l (d@nil slink/area-limit) vector)
  520.     (j> AN vector %horrible-heap-overflow)
  521.     (store l nil-reg (d@nil slink/doing-gc?))
  522.     (jbr %set-continue)
  523.  
  524. %kernel-end
  525.   (noop)      
  526. %horrible-heap-overflow
  527.     (store l nil-reg (d@nil slink/doing-gc?))
  528.     (load l (d@nil slink/kernel) P)
  529.     (load l (d@r P (static heap-overflow-error)) P)
  530.     (load l (d@r p 2) p)
  531.     (load l (d@r P -2) extra)
  532.     (jr (d@r extra 2))
  533.     (move ($ 1) nargs)
  534.  
  535. %undefined-effect
  536.   (sub ($ 2) link-reg a2)
  537.   (load l (d@nil slink/kernel) P)
  538.   (load l (d@r P (static handle-undefined-effect)) P)
  539.   (load l (d@r p 2) p)
  540.   (load l (d@r P -2) extra)
  541.   (jr (d@r extra 2))
  542.   (move ($ 3) nargs)
  543. ))                         
  544.  
  545. (define (gc)
  546.   (lap ()
  547.     (store l zero (d@nil slink/doing-gc?))
  548.     (move link-reg extra)            ;heap overflow moves it back
  549.     (jl %heap-overflow) 
  550.     (noop)
  551.     (store l nil-reg (d@nil slink/doing-gc?))
  552.     (jr (d@r link-reg 0))
  553.     (move ($ -1) nargs)))
  554.     
  555.  
  556.                  
  557. (lap-template (0 1 nil stack stack-base-handler)
  558. stack-base-template
  559.   (load l (d@nil slink/undefined-effect) extra)
  560.   (jr (d@r extra 0))
  561.   (noop)
  562. stack-base-handler
  563.   (load l (d@nil slink/kernel) AN)
  564.   (load l (d@r AN (static handle-stack-base)) A1)
  565.   (load l (d@r a1 2) a1)
  566.   (load l (d@nil slink/dispatch-label) extra)
  567.   (jr (d@r extra 0))
  568.   (noop))
  569.     
  570.  
  571. ; debugger hacks
  572.  
  573. (define (@@ address)    ; randomness
  574.   (lap ()
  575.     (add ($ 2) a1)
  576.     (jr (d@r link-reg 0))
  577.     (move ($ -2) nargs)))
  578.  
  579. ;(define-foreign gc-interrupt ("gc_interrupt") ignore)
  580.  
  581. (define (crawl-exhibit-interrupt-frame frame)
  582.   (print-register frame 'an+1 3)
  583.   (print-register frame 'an 4)
  584.   (print-register frame 'a11 5)
  585.   (print-register frame 'a10 6)
  586.   (print-register frame 'a9 7)
  587.   (print-register frame 'a8 8)
  588.   (print-register frame 'a7 9)
  589.   (print-register frame 'a6 10)
  590.   (print-register frame 'a5 11)
  591.   (print-register frame 'a4 12)
  592.   (print-register frame 'a3 13)
  593.   (print-register frame 'a2 14)
  594.   (print-register frame 'a1 15)
  595.   (print-register frame 'p 16))
  596.   
  597.  
  598.  
  599. (define (make-link-snapper value unit i)
  600.   (lap ()
  601.     (load l (d@nil slink/snapper-freelist) p)
  602.     (j= p nil-reg cons-snapper-1)
  603.     (load l (d@r p %%car) an)
  604.     (load l (d@r p %%cdr) extra)
  605.     (store l extra (d@nil slink/snapper-freelist))
  606.     (load l (d@nil slink/pair-freelist) extra)
  607.     (store l extra (d@r p %%cdr))
  608.     (store l p (d@nil slink/pair-freelist))
  609. foobarfoo
  610.     (store l a1 (d@r an 2))
  611.     (store l a2 (d@r an 6))
  612.     (store l a3 (d@r an 10))
  613.     (move an a1)
  614.     (jr (d@r link-reg 0))
  615.     (move ($ -2) nargs)
  616. cons-snapper-1
  617.     (sub ($ 4) sp)
  618.     (store l link-reg (d@r sp 0))
  619.     (movea link-snapper an)
  620.     (sub ($ 2) an)            ;make code address it a template!
  621.     (move ($ 12) scratch)
  622.     (jl %make-extend)
  623.     (add ($ 12) link-reg)
  624.     (template 0 -1 t)
  625.     (load l (d@r sp 0) link-reg)
  626.     (add ($ 4) sp)
  627.     (jbr foobarfoo)))
  628.  
  629. (define *link-snapper-template*
  630. (lap-template (3 1 t heap handle-snapper)
  631. link-snapper
  632.   (move p an)
  633.   (load l (d@r p 2) p)
  634.   (mask ($ 3) P vector)
  635.   (jn= vector ($ tag/extend) %icall-bad-proc)
  636.   (load l (d@r P -2) parassign-extra)                         ; fetch header
  637.   (mask ($ 3) parassign-extra vector)                 ; check header is extend
  638.   (jn= vector ($ tag/extend) %icall-bad-proc)
  639.   (load ub (d@r parassign-extra template/header) vector)
  640.   (jn= vector ($ header/template) %icall-check-nary-l)
  641.   (load ub (d@r parassign-extra template/nargs) vector)
  642.   (j= vector NARGS snap-link)         ; check number of args
  643.   (jbr %icall-wrong-nargs)
  644. %icall-check-nary-l
  645.   (jn= vector ($ (fx+ header/template 128)) %icall-bad-proc)
  646.   (load ub (d@r parassign-extra template/nargs) vector)
  647.   (j> vector NARGS %icall-wrong-nargs)
  648. snap-link
  649.   (load l (d@r an 10) vector)
  650.   (load l (d@r an 6) extra)
  651.   (add extra vector)
  652.   (store l p (d@r vector 2))
  653.   (move an parassign-extra)
  654.   (load l (d@nil slink/pair-freelist) an)
  655.   (j= an nil-reg cons-pair)
  656.   (load l (d@r an %%cdr) extra)
  657.   (store l extra (d@nil slink/pair-freelist))
  658. consed-pair
  659.   (store l parassign-extra (d@r an %%car))
  660.   (load l (d@nil slink/snapper-freelist) extra)
  661.   (store l extra (d@r an %%cdr))
  662.   (store l an (d@nil slink/snapper-freelist))
  663.   (load l (d@r p -2) extra)
  664.   (jr (d@r extra 2))
  665.   (noop)
  666. cons-pair
  667.   (sub ($ 4) sp)
  668.   (store l link-reg (d@r sp 0))
  669.   (jl %make-pair)
  670.   (add ($ 12) link-reg)
  671.   (template 0 -1 t)
  672.   (load l (d@r sp 0) link-reg)
  673.   (add ($ 4) sp)
  674.   (jbr consed-pair)
  675. handle-snapper
  676.   (jr (d@r link-reg 0))
  677.   (move nil-reg AN)))
  678. #|
  679. (define (reset-ssp ssp)
  680.   (lap ()
  681.     (move a1 ssp)
  682.     (jr (d@r link-reg 0))
  683.     (move ($ -1) nargs)))
  684. |#